home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 2 / CU Amiga Magazine's Super CD-ROM 02 (1996)(EMAP Images)(GB)[!][issue 1996-04].iso / magazine / amiga_e / yax / yax.e < prev   
Text File  |  1992-09-02  |  29KB  |  952 lines
  1. /* YAX (Yet Another Instruction Code Set) Interpreter v1.2
  2.    simple procedural/(functional) language with lisp-lookalike syntax.
  3.    eats sources with extension .yax for dinner.               */
  4.  
  5. /* v1.2 now includes as mass of new functions! see doc. at end of source */
  6.  
  7. OPT STACK=25000     /* we do heavy recursion */
  8.  
  9. OBJECT var          /* this is where we store our runtime values */
  10.   type:INT
  11.   name:LONG
  12.   value:LONG
  13. ENDOBJECT
  14.  
  15. /* intermed'
  16. iate codes */
  17. ENUM ENDSOURCE,VALUE,ISTRING,IDENT,LBRACKET,RBRACKET
  18.  
  19. /* keywords */
  20. ENUM FWRITE=100,FADD,FEQ,FUNEQ,FSUB,FMUL,FDIV,FAND,FORX,FNOT,FIF,FDO,
  21.      FSELECT,FSET,FFOR,FWHILE,FUNTIL,FDEFUN,FLAMBDA,FAPPLY,FREADINT,
  22.      FARRAY,FGREATER,FSMALLER,FLOCATE,FCLS,FDUMP,FWINDOW,FTELL,FTOLD,
  23.      FSEE,FSEEN,FSTRING,FREAD,FGET,FPUT,FFILELEN,FLINE,FPLOT,FBOX,
  24.      FMOUSEX,FMOUSEY,FMOUSE,FTEXT,FABS,FMOD,FEOR,FSWAP,FPOWER,FREQ,
  25.      FINC,FDEC,FRND,FRNDQ,FKICK,FWHEN,FELSE,FWIN,FSCREEN,FMESSAGE,
  26.      FGADGET,FGADNUM,FHEX,FEXIT,LAST
  27.  
  28. CONST KEYWORDSIZE=8,
  29.       NRKEYWORDS=LAST-99,
  30.       IDENTNAMESPACE=30000,
  31.       VARSTACKSPACE=50000,
  32.       MAXARGS=5,
  33.       ERLEN=60
  34.  
  35. /* errors */
  36. ENUM ER_WORKSPACE=1,ER_BUF,ER_GARBAGE,ER_SYNTAX,ER_EXPKEYWORD,ER_EXPRBRACKET,
  37.      ER_EXPEXP,ER_QUOTE,ER_COMMENT,ER_INFILE,ER_SOURCEMEM,ER_EXPIDENT,
  38.      ER_ARGS,ER_TYPE,ER_EXPLBRACKET,ER_STACK,ER_ALLOC,ER_ARRAY,ER_FILE,
  39.      ER_GFXWIN,ER_VALUES,ER_KICK
  40.  
  41. /* variable types */
  42. ENUM TINTEGER=1,TSTRING,TFUNC,TARRAY
  43.  
  44. DEF source,slen,erpos=NIL,
  45.     ilen,ibuf,ipos:PTR TO INT,p:PTR TO INT,idents,
  46.     name[100]:STRING,wfile,
  47.     inputbuf[100]:STRING,winspec[100]:STRING,
  48.     vartop,varbottom,vars,rec,globvar,
  49.     infile,outfile,oldout,oldin,stdin,
  50.     gfxwindow=NIL,curwindow=NIL,curscreen=NIL,gadnum=-1
  51.  
  52. PROC main()
  53.   WriteF(''); stdin:=stdout
  54.   loadsource()
  55.   ilen:=Mul(slen,4)+1000       /* guess the needed workspace */
  56.   ibuf:=New(ilen+10)
  57.   idents:=String(IDENTNAMESPACE)
  58.   vars:=New(VARSTACKSPACE)
  59.   vartop:=vars; varbottom:=vars
  60.   IF (ibuf=NIL) OR (idents=NIL) OR (vars=NIL)
  61.     error(ER_WORKSPACE)
  62.   ELSE 
  63.     lexanalyse()               /* translate to intermediate format */
  64.     p:=ibuf
  65.     WHILE p[]<>ENDSOURCE DO eval()       /* run the code */
  66.   ENDIF
  67.   error(0)
  68. ENDPROC
  69.  
  70. PROC lexanalyse()
  71.   DEF pos,end,c,count,ident[50]:STRING,pos2,keypos,a,nr,ident2[50]:STRING
  72.   pos:=source; end:=pos+slen; ipos:=ibuf; erpos:=pos
  73.   StrCopy(idents,' ',1)
  74.   loop:
  75.   c:=pos[]++
  76.   IF c>96                          /* an identifier */
  77.     pos2:=pos-1
  78.     WHILE pos[]++>96 DO NOP; DEC pos
  79.     StrCopy(ident,pos2,pos-pos2)
  80.     StrCopy(ident2,ident,ALL)
  81.     StrAdd(ident,'..............',ALL)
  82.     keypos:={keywords}
  83.     nr:=0
  84.     FOR a:=1 TO NRKEYWORDS         /* lookup keywords */
  85.       IF StrCmp(ident,keypos,KEYWORDSIZE)
  86.         nr:=99+a
  87.         JUMP found
  88.       ENDIF
  89.       keypos:=keypos+KEYWORDSIZE
  90.     ENDFOR
  91.     found:
  92.     IF nr>0                        /* keyword */
  93.       iword(nr)
  94.     ELSE                           /* own identifier */
  95.       iword(IDENT)
  96.       StrCopy(ident,' ',1)
  97.       StrAdd(ident,ident2,ALL)
  98.       StrAdd(ident,' ',1)
  99.       pos2:=InStr(idents,ident,0)
  100.       IF pos2=-1
  101.         ilong(EstrLen(idents)+idents)
  102.         StrAdd(idents,ident2,ALL)
  103.         StrAdd(idents,' ',1)
  104.         IF EstrLen(idents)=StrMax(idents) THEN error(ER_WORKSPACE)
  105.       ELSE
  106.         ilong(pos2+idents+1)
  107.       ENDIF
  108.     ENDIF
  109.   ELSE
  110.     SELECT c                       /* anything else */
  111.       CASE " "
  112.         IF pos<end THEN JUMP loop
  113.       CASE "("
  114.         iword(LBRACKET)
  115.         erpos:=pos-1
  116.         ilong(erpos)
  117.       CASE ")"; iword(RBRACKET)
  118.       CASE "+"; iword(FADD)
  119.       CASE "-"
  120.         IF pos[]=" "
  121.           iword(FSUB)
  122.         ELSE
  123.           iword(VALUE)
  124.           ilong(-Val(pos,{c}))
  125.           IF c=0 THEN error(ER_GARBAGE) ELSE pos:=pos+c
  126.         ENDIF
  127.       CASE "*"; iword(FMUL)
  128.       CASE "/"
  129.         IF pos[]<>"*"
  130.           iword(FDIV)
  131.         ELSE                       /* comment (like this one) */
  132.           INC pos
  133.           WHILE pos-1<end
  134.             INC count
  135.             IF (pos[]++="*") AND (pos[]="/") THEN JUMP out
  136.           ENDWHILE
  137.           error(ER_COMMENT)
  138.           out:
  139.           INC pos
  140.         ENDIF
  141.       CASE "="
  142.         iword(FEQ)
  143.       CASE ">"
  144.         iword(FGREATER)
  145.       CASE "<"
  146.         iword(FSMALLER)
  147.       CASE "?"
  148.         iword(FUNEQ)
  149.       CASE "'"                     /* string constant */
  150.         iword(ISTRING)
  151.         count:=0; pos2:=pos
  152.         WHILE pos[]++<>"'"
  153.           INC count
  154.           IF pos=end THEN error(ER_QUOTE)
  155.         ENDWHILE
  156.         iword(count)
  157.         ilong(pos2)                /* char adress */
  158.       CASE 10
  159.         IF pos<end THEN JUMP loop
  160.       CASE 0
  161.         pos:=end
  162.       CASE 9
  163.         IF pos<end THEN JUMP loop
  164.       DEFAULT
  165.         iword(VALUE)
  166.         ilong(Val(pos--,{c}))
  167.         IF c=0 THEN error(ER_GARBAGE) ELSE pos:=pos+c
  168.     ENDSELECT
  169.   ENDIF
  170.   IF pos<end THEN JUMP loop
  171.   iword(ENDSOURCE)
  172. ENDPROC
  173.  
  174. PROC checkstop()
  175.   IF FreeStack()<1000 THEN error(ER_STACK)
  176.   IF CtrlC() THEN error(-1)
  177. ENDPROC
  178.  
  179. PROC eval()                        /* main recursive evaluation function */
  180.   DEF r=0,i,ins,p2,x:PTR TO LONG,a,adr:PTR TO var
  181.   checkstop()
  182.   i:=p[]++
  183.   SELECT i
  184.     CASE VALUE
  185.       r:=^p++
  186.     CASE IDENT
  187.       r:=varvalue(^p++,TINTEGER)
  188.     CASE LBRACKET
  189.       erpos:=^p++
  190.       ins:=p[]++
  191.       IF ins=IDENT
  192.         adr:=findvar(^p++)
  193.         IF adr.type=TFUNC
  194.           r:=dofunc(adr.value)
  195.         ELSE
  196.           IF adr.type<>TARRAY THEN error(ER_TYPE)
  197.           x:=adr.value
  198.           a:=eval()
  199.           IF (a<0) OR (a>x[]) THEN error(ER_ARRAY)
  200.           r:=x[a+1]
  201.         ENDIF
  202.       ELSE
  203.         IF ins<100 THEN error(ER_EXPKEYWORD)
  204.         SELECT ins
  205.           CASE FWRITE                /* output string constants + expressions */
  206.             x:=TRUE
  207.             WHILE p[]<>RBRACKET
  208.               IF p[]=ISTRING
  209.                 Write(stdout,Long(p+4),p[1])
  210.                 IF (p[1]=0) AND (p[4]=RBRACKET) THEN x:=FALSE
  211.                 p:=p+8
  212.               ELSEIF p[]=IDENT
  213.                 IF (Int(findvar(Long(p+2)))=TSTRING)
  214.                   WriteF('\s',eatstring())
  215.                 ELSE
  216.                   WriteF('\d',eval())
  217.                 ENDIF
  218.               ELSE
  219.                 WriteF('\d',eval())
  220.               ENDIF
  221.             ENDWHILE
  222.             IF x THEN WriteF('\n')
  223.           CASE FEQ
  224.             r:=TRUE
  225.             x:=eval()
  226.             WHILE p[]<>RBRACKET DO IF x<>eval() THEN r:=FALSE
  227.           CASE FUNEQ; r:=eval()<>eval()
  228.           CASE FGREATER; r:=eval()>eval()
  229.           CASE FSMALLER; r:=eval()<eval()
  230.           CASE FADD; r:=eval(); WHILE p[]<>RBRACKET DO r:=r+eval()
  231.           CASE FSUB; r:=eval(); WHILE p[]<>RBRACKET DO r:=r-eval()
  232.           CASE FMUL; r:=eval(); WHILE p[]<>RBRACKET DO r:=Mul(r,eval())
  233.           CASE FDIV; r:=eval(); WHILE p[]<>RBRACKET DO r:=r/eval()
  234.           CASE FAND; r:=eval(); WHILE p[]<>RBRACKET DO r:=r AND eval()
  235.           CASE FORX; r:=eval(); WHILE p[]<>RBRACKET DO r:=r OR eval()
  236.           CASE FEOR; r:=eval(); WHILE p[]<>RBRACKET DO r:=Eor(r,eval())
  237.           CASE FNOT; r:=Not(eval())
  238.           CASE FABS; r:=Abs(eval())
  239.           CASE FRND; r:=Rnd(eval())
  240.           CASE FRNDQ; r:=RndQ(eval())
  241.           CASE FKICK; r:=KickVersion(eval())
  242.           CASE FMOD; r:=Mod(eval(),eval())
  243.           CASE FWHEN
  244.             IF eval()
  245.               WHILE (p[]<>FELSE) AND (p[]<>RBRACKET) DO r:=eval()
  246.               IF p[]=FELSE
  247.                 p++
  248.                 WHILE (p[]<>RBRACKET) DO skip()
  249.               ENDIF
  250.             ELSE
  251.               WHILE (p[]<>FELSE) AND (p[]<>RBRACKET) DO skip()
  252.               IF p[]=FELSE
  253.                 p++
  254.                 WHILE (p[]<>RBRACKET) DO r:=eval()
  255.               ENDIF
  256.             ENDIF
  257.           CASE FIF
  258.             IF eval()
  259.               r:=eval()
  260.               IF p[]<>RBRACKET THEN skip()
  261.             ELSE
  262.               skip()
  263.               IF p[]<>RBRACKET THEN r:=eval()
  264.             ENDIF
  265.           CASE FDO; WHILE p[]<>RBRACKET DO r:=eval()
  266.           CASE FSELECT
  267.             x:=eval()
  268.             WHILE p[]<>RBRACKET DO IF x=eval() THEN r:=eval() ELSE skip()
  269.           CASE FSET
  270.             IF p[]=LBRACKET
  271.               p:=p+2
  272.               erpos:=^p++
  273.               x:=varvalue(eatident(),TARRAY)
  274.               a:=eval()
  275.               IF (a<0) OR (a>x[0]) THEN error(ER_ARRAY)
  276.               IF p[]++<>RBRACKET THEN error(ER_EXPRBRACKET)
  277.               x[a+1]:=eval()
  278.             ELSE
  279.               x:=eatident()
  280.               IF (p[]=LBRACKET) AND (p[3]=FLAMBDA)
  281.                 p:=p+8
  282.                 adr:=findvar(x)
  283.                 letvar(adr,p,TFUNC)
  284.                 WHILE p[]<>RBRACKET DO skip()
  285.                 p:=p+2
  286.               ELSEIF p[]=ISTRING
  287.                 r:=eatstring()
  288.                 x:=findvar(x)
  289.                 letvar(x,r,TSTRING)
  290.               ELSE
  291.                 r:=eval()
  292.                 x:=findvar(x)
  293.                 letvar(x,r,TINTEGER)
  294.               ENDIF
  295.             ENDIF
  296.           CASE FINC
  297.             x:=eatident()
  298.             r:=varvalue(x,TINTEGER)
  299.             x:=findvar(x)
  300.             letvar(x,r+1,TINTEGER)
  301.           CASE FDEC
  302.             x:=eatident()
  303.             r:=varvalue(x,TINTEGER)
  304.             x:=findvar(x)
  305.             letvar(x,r-1,TINTEGER)
  306.           CASE FSWAP
  307.             x:=eatident()
  308.             r:=varvalue(x,TINTEGER)
  309.             x:=findvar(x)
  310.             adr:=eatident()
  311.             a:=varvalue(adr,TINTEGER)
  312.             adr:=findvar(adr)
  313.             letvar(x,a,TINTEGER)
  314.             letvar(adr,r,TINTEGER)
  315.             r:=0
  316.           CASE FPOWER
  317.             r:=adr:=eval()
  318.             x:=eval()
  319.             IF x>1 THEN FOR a:=2 TO x DO r:=r*adr
  320.           CASE FFOR
  321.             x:=eatident()
  322.             r:=eval()
  323.             adr:=findvar(x)
  324.             x:=eval()
  325.             p2:=p
  326.             IF r>x               /* downto */
  327.               FOR a:=r TO x STEP -1
  328.                 p:=p2
  329.                 letvar(adr,a,TINTEGER)
  330.                 WHILE p[]<>RBRACKET DO eval()
  331.               ENDFOR
  332.             ELSE
  333.               FOR a:=r TO x
  334.                 p:=p2
  335.                 letvar(adr,a,TINTEGER)
  336.                 WHILE p[]<>RBRACKET DO eval()
  337.               ENDFOR
  338.             ENDIF
  339.             r:=0
  340.           CASE FWHILE
  341.             p2:=p
  342.             WHILE eval()
  343.               WHILE p[]<>RBRACKET DO eval()
  344.               p:=p2
  345.             ENDWHILE
  346.             WHILE p[]<>RBRACKET DO skip()
  347.             r:=0
  348.           CASE FUNTIL
  349.             p2:=p
  350.             WHILE eval()=FALSE
  351.               WHILE p[]<>RBRACKET DO eval()
  352.               p:=p2
  353.             ENDWHILE
  354.             WHILE p[]<>RBRACKET DO skip()
  355.             r:=0
  356.           CASE FDEFUN
  357.             x:=eatident()
  358.             adr:=findvar(x)
  359.             letvar(adr,p,TFUNC)
  360.             WHILE p[]<>RBRACKET DO skip()
  361.           CASE FLAMBDA; error(ER_SYNTAX)
  362.           CASE FAPPLY
  363.             IF p[]<>IDENT
  364.               IF (p[]<>LBRACKET) OR (p[3]<>FLAMBDA) THEN error(ER_EXPIDENT)
  365.               p:=p+8; adr:=p
  366.               WHILE p[]<>RBRACKET DO skip()
  367.               p:=p+2
  368.               r:=dofunc(adr)
  369.             ELSE
  370.               p:=p+2
  371.               r:=dofunc(varvalue(^p++,TFUNC))
  372.             ENDIF
  373.           CASE FREADINT
  374.             IF ReadStr(stdin,inputbuf)=-1
  375.               r:=0
  376.             ELSE
  377.               r:=Val(inputbuf,{x})
  378.             ENDIF
  379.           CASE FARRAY
  380.             adr:=findvar(eatident())
  381.             a:=eval()
  382.             x:=New(Mul(a,4)+8)
  383.             IF x=NIL THEN error(ER_ALLOC)
  384.             letvar(adr,x,TARRAY)
  385.             x[]++:=a
  386.             WHILE (p[]++=VALUE)
  387.               IF a-->=0 THEN x[]++:=^p++ ELSE p:=p+4
  388.             ENDWHILE
  389.             p--
  390.           CASE FLOCATE; WriteF('\e[\d;\dH',eval(),eval())
  391.           CASE FCLS; Out(stdout,12)
  392.           CASE FDUMP
  393.             adr:=varbottom
  394.             WriteF('\n')
  395.             WHILE adr<vartop
  396.               a:=adr.name
  397.               x:=a
  398.               WHILE Char(x)<>" " DO INC x
  399.               Write(stdout,a,x-a)
  400.               x:=adr.type
  401.               SELECT x
  402.                 CASE TINTEGER; WriteF(' = \d (int)\n',adr.value)
  403.                 CASE TSTRING;  WriteF(' = "\s" (string)\n',adr.value)
  404.                 CASE TFUNC;    WriteF(' (function)\n')
  405.                 CASE TARRAY;   WriteF('[\d] (array)\n',Long(adr.value))
  406.               ENDSELECT
  407.               adr:=adr+SIZEOF var
  408.             ENDWHILE
  409.             WriteF('\n')
  410.           CASE FWINDOW
  411.             StringF(winspec,'CON:\d/\d/\d/\d/',eval(),eval(),eval(),eval())
  412.             x:=eatstring()
  413.             StrAdd(winspec,x,ALL)
  414.             wfile:=Open(winspec,1006)
  415.             IF wfile=NIL THEN error(ER_FILE)
  416.             IF conout<>NIL THEN Close(conout)
  417.             stdout:=wfile
  418.             conout:=stdout
  419.             stdin:=stdout
  420.             adr:=OpenWorkBench()
  421.             Forbid()
  422.             a:=NIL
  423.             IF adr<>NIL
  424.               adr:=Long(adr+4)
  425.               WHILE (adr<>NIL) AND (a=NIL)
  426.                 IF StrCmp(x,Long(adr+32),ALL) THEN a:=adr
  427.                 adr:=^adr
  428.               ENDWHILE
  429.             ENDIF
  430.             Permit()
  431.             IF a THEN gfxwindow:=a
  432.           CASE FREQ
  433.             IF KickVersion(37)=FALSE THEN error(ER_KICK)
  434.             r:=EasyRequestArgs(IF curwindow THEN curwindow ELSE NIL,
  435.                    [20,0,eatstring(),eatstring(),eatstring()],0,NIL)
  436.           CASE FTELL
  437.             IF outfile<>NIL THEN Close(outfile)
  438.             outfile:=NIL
  439.             outfile:=Open(eatstring(),1006)
  440.             IF outfile=NIL THEN error(ER_FILE)
  441.             oldout:=stdout
  442.             stdout:=outfile
  443.           CASE FTOLD
  444.             IF outfile<>NIL THEN Close(outfile)
  445.             outfile:=NIL
  446.             stdout:=oldout
  447.           CASE FSEE
  448.             IF infile<>NIL THEN Close(infile)
  449.             infile:=NIL
  450.             infile:=Open(eatstring(),1005)
  451.             IF infile=NIL THEN error(ER_FILE)
  452.             oldin:=stdin
  453.             stdin:=infile
  454.           CASE FSEEN
  455.             IF infile<>NIL THEN Close(infile)
  456.             infile:=NIL
  457.             stdin:=oldin
  458.           CASE FSTRING
  459.             adr:=String(250)
  460.             IF adr=NIL THEN error(ER_ALLOC)
  461.             letvar(findvar(eatident()),adr,TSTRING)
  462.           CASE FREAD
  463.             x:=varvalue(eatident(),TSTRING)
  464.             r:=ReadStr(stdin,x)
  465.           CASE FGET; r:=Inp(stdin)
  466.           CASE FPUT; r:=eval(); IF r<>-1 THEN Out(stdout,r)
  467.           CASE FFILELEN
  468.             r:=FileLength(eatstring())
  469.             IF r=-1 THEN r:=0
  470.           CASE FLINE; getrast(); Line(eval(),eval(),eval(),eval(),eval())
  471.           CASE FPLOT; getrast(); Plot(eval(),eval(),eval())
  472.           CASE FBOX
  473.             getrast()
  474.             a:=eval(); x:=eval(); p2:=eval(); r:=eval()
  475.             IF a>p2
  476.               adr:=a; a:=p2; p2:=adr
  477.             ENDIF
  478.             IF x>r
  479.               adr:=x; x:=r; r:=adr
  480.             ENDIF
  481.             IF (a<0) OR (x<0) OR (p2>10000) OR (r>10000) THEN error(ER_VALUES)
  482.             Box(a,x,p2,r,eval())
  483.             r:=0
  484.           CASE FMOUSEX; r:=MouseX(getwin())
  485.           CASE FMOUSEY; r:=MouseY(getwin())
  486.           CASE FMOUSE; r:=Mouse()
  487.           CASE FTEXT
  488.             adr:=getrast()
  489.             a:=eval(); x:=eval()
  490.             Colour(eval(),eval())
  491.             TextF(a,x,eatstring())
  492.             r:=0
  493.           CASE FMESSAGE
  494.             r:=WaitIMessage(getwin())
  495.             gadnum:=IF (r=$20) OR (r=$40) THEN Long(MsgIaddr()+40) ELSE -1
  496.           CASE FGADNUM
  497.             r:=gadnum
  498.           CASE FGADGET
  499.             IF (adr:=New(GADGETSIZE))=NIL THEN error(ER_ALLOC)
  500.             Gadget(adr,NIL,eval(),0,eval(),eval(),eval(),eatstring())
  501.             AddGadget(getwin(),adr,-1)
  502.             RefreshGList(adr,getwin(),NIL,1)
  503.           CASE FSCREEN
  504.             CloseS(curscreen)
  505.             curscreen:=NIL
  506.             curscreen:=OpenS(eval(),eval(),eval(),eval(),eatstring())
  507.           CASE FWIN
  508.             CloseW(curwindow)
  509.             curwindow:=NIL
  510.             gfxwindow:=NIL
  511.             curwindow:=OpenW(eval(),eval(),eval(),eval(),
  512.                              eval(),eval(),eatstring(),
  513.                              IF curscreen THEN curscreen ELSE NIL,
  514.                              IF curscreen THEN 15 ELSE 1,NIL)
  515.             gfxwindow:=curwindow
  516.           CASE FHEX
  517.             WriteF('$\z\h[8]',eval())
  518.           CASE FEXIT
  519.             error(0)
  520.         ENDSELECT
  521.       ENDIF
  522.       IF p[]++<>RBRACKET THEN error(ER_EXPRBRACKET)
  523.     DEFAULT
  524.       IF (i=RBRACKET) OR (i=ISTRING) THEN error(ER_EXPEXP) ELSE error(ER_SYNTAX)
  525.   ENDSELECT
  526. ENDPROC r
  527.  
  528. PROC getwin()
  529.   IF gfxwindow=NIL THEN error(ER_GFXWIN)
  530. ENDPROC gfxwindow
  531.  
  532. PROC getrast()
  533.   DEF r
  534.   IF curwindow=NIL
  535.     IF curscreen=NIL
  536.       IF gfxwindow=NIL THEN error(ER_GFXWIN)
  537.       r:=Long(gfxwindow+50)
  538.     ELSE
  539.       r:=curscreen+84
  540.     ENDIF
  541.   ELSE
  542.     r:=Long(curwindow+50)
  543.   ENDIF
  544.   SetStdRast(r)
  545. ENDPROC r
  546.  
  547. PROC eatstring()
  548.   DEF adr,x
  549.   IF p[]=ISTRING
  550.     p:=p+2; x:=p[]++; adr:=^p++
  551.     adr[x]:=0
  552.   ELSE
  553.     adr:=varvalue(eatident(),TSTRING)
  554.   ENDIF
  555. ENDPROC adr
  556.  
  557. PROC eatident()
  558.   IF p[]++<>IDENT THEN error(ER_EXPIDENT)
  559. ENDPROC ^p++
  560.  
  561. PROC dofunc(lcode)
  562.   DEF args[MAXARGS]:ARRAY OF LONG,a=0,oldvarb,oldvart,oldp,x,r=0,olderpos
  563.   checkstop()
  564.   WHILE p[]<>RBRACKET
  565.     IF a=MAXARGS THEN error(ER_ARGS)
  566.     args[a]:=eval()
  567.     INC a
  568.   ENDWHILE
  569.   IF rec=0 THEN globvar:=vartop
  570.   oldvarb:=varbottom; varbottom:=vartop; oldvart:=vartop;
  571.   oldp:=p; p:=lcode; olderpos:=erpos; INC rec
  572.   IF p[]++<>LBRACKET THEN error(ER_EXPLBRACKET)
  573.   erpos:=^p++
  574.   WHILE p[]<>RBRACKET
  575.     IF a=0 THEN error(ER_ARGS)
  576.     x:=findvar(eatident())
  577.     letvar(x,args[]++,TINTEGER)
  578.     DEC a
  579.   ENDWHILE
  580.   IF a<>0 THEN error(ER_ARGS)
  581.   p:=p+2
  582.   WHILE p[]<>RBRACKET DO r:=eval()
  583.   varbottom:=oldvarb; vartop:=oldvart; p:=oldp; erpos:=olderpos; DEC rec
  584. ENDPROC r
  585.  
  586. PROC findvar(id)
  587.   DEF loc=0:PTR TO var,a:PTR TO var
  588.   IF vartop<>varbottom
  589.     a:=varbottom                     /* check existing local vars */
  590.     WHILE (a<vartop) AND (loc=0)
  591.       IF a.name=id THEN loc:=a
  592.       a:=a+SIZEOF var
  593.     ENDWHILE
  594.   ENDIF
  595.   IF loc=0
  596.     IF (rec>0) AND (globvar>vars)    /* check global vars */
  597.       a:=vars
  598.       WHILE (a<globvar) AND (loc=0)
  599.         IF a.name=id THEN loc:=a
  600.         a:=a+SIZEOF var
  601.       ENDWHILE
  602.     ENDIF
  603.     IF loc=0                         /* create new var dynamically */
  604.       loc:=vartop
  605.       vartop:=vartop+SIZEOF var
  606.       IF vars+VARSTACKSPACE<vartop THEN error(ER_WORKSPACE)
  607.       loc.type:=TINTEGER
  608.       loc.name:=id
  609.       loc.value:=0
  610.     ENDIF
  611.   ENDIF
  612. ENDPROC loc
  613.  
  614. PROC letvar(adr:PTR TO var,value,type)
  615.   IF (adr.type<>type) AND (adr.type<>TINTEGER) THEN error(ER_TYPE)
  616.   checkstop()
  617.   adr.type:=type
  618.   adr.value:=value
  619. ENDPROC
  620.  
  621. PROC varvalue(id,type)
  622.   DEF adr:PTR TO var
  623.   checkstop()
  624.   adr:=findvar(id)
  625.   IF adr.type<>type THEN error(ER_TYPE)
  626. ENDPROC adr.value
  627.  
  628. PROC skip()                        /* skip *one* expression */
  629.   DEF deep=0,i
  630.   REPEAT
  631.     i:=p[]++
  632.     IF (i=VALUE) OR (i=LBRACKET) OR (i=IDENT) THEN p:=p+4
  633.     IF i=ISTRING THEN p:=p+6
  634.     IF i=LBRACKET THEN INC deep
  635.     IF i=RBRACKET THEN IF deep=0 THEN error(ER_EXPEXP) ELSE DEC deep
  636.     IF i=ENDSOURCE THEN error(ER_EXPRBRACKET)
  637.   UNTIL deep=0
  638. ENDPROC
  639.  
  640. PROC iword(x)
  641.   IF ibuf+ilen>ipos THEN ipos[]++:=x ELSE error(ER_BUF)
  642. ENDPROC
  643.  
  644. PROC ilong(x)
  645.   IF ibuf+ilen>ipos THEN ^ipos++:=x ELSE error(ER_BUF)
  646. ENDPROC
  647.  
  648. PROC loadsource()
  649.   DEF suxxes=FALSE,handle,read
  650.   IF StrCmp(arg,'?',ALL) OR StrCmp(arg,'',ALL)
  651.     WriteF('USAGE: Yax <source> (default ext. ".yax")\n')
  652.     error(0)
  653.   ELSE
  654.     StrCopy(name,arg,ALL)
  655.     StrAdd(name,'.yax',4)
  656.     slen:=FileLength(name)
  657.     handle:=Open(name,1005)
  658.     IF (handle=NIL) OR (slen=-1)
  659.       error(ER_INFILE)
  660.     ELSE
  661.       source:=New(slen+10)
  662.       IF source=NIL
  663.         error(ER_SOURCEMEM)
  664.       ELSE
  665.         read:=Read(handle,source,slen)
  666.         Close(handle)
  667.         IF read=slen 
  668.           suxxes:=TRUE
  669.           source[slen]:=0
  670.         ELSE
  671.           error(ER_INFILE)
  672.         ENDIF
  673.       ENDIF
  674.     ENDIF
  675.   ENDIF
  676. ENDPROC
  677.  
  678. PROC error(nr)
  679.   DEF erstr[ERLEN]:STRING,a
  680.   IF outfile
  681.     IF stdout=outfile THEN stdout:=oldout
  682.     Close(outfile)
  683.   ENDIF
  684.   IF infile
  685.     IF stdin=infile THEN stdin:=oldin
  686.     Close(infile)
  687.   ENDIF
  688.   CloseW(curwindow)
  689.   CloseS(curscreen)
  690.   WriteF('\n')
  691.   IF nr>0
  692.     WriteF('ERROR: ')
  693.     SELECT nr
  694.       CASE ER_WORKSPACE;   WriteF('Could not allocate workspace!\n')
  695.       CASE ER_BUF;         WriteF('Buffer overflow!\n')
  696.       CASE ER_GARBAGE;     WriteF('Garbage in line\n')
  697.       CASE ER_SYNTAX;      WriteF('Your syntax sucks\n')
  698.       CASE ER_EXPKEYWORD;  WriteF('Keyword identifier expected\n')
  699.       CASE ER_EXPRBRACKET; WriteF('Right bracket expected\n')
  700.       CASE ER_EXPEXP;      WriteF('Evaluateable expression expected\n')
  701.       CASE ER_QUOTE;       WriteF('Missing quote \a\n')
  702.       CASE ER_COMMENT;     WriteF('Missing "*/"\n')
  703.       CASE ER_SOURCEMEM;   WriteF('No Memory for source!\n')
  704.       CASE ER_INFILE;      WriteF('Could not open file "\s".\n',name)
  705.       CASE ER_EXPIDENT;    WriteF('Identifier expected\n')
  706.       CASE ER_ARGS;        WriteF('Illegal #of arguments\n')
  707.       CASE ER_TYPE;        WriteF('Wrong type of variable/expression\n')
  708.       CASE ER_EXPLBRACKET; WriteF('Left bracket expected\n')
  709.       CASE ER_STACK;       WriteF('Nearly stack overflow: \d deep\n',rec)
  710.       CASE ER_ALLOC;       WriteF('Dynamic allocation failed!\n')
  711.       CASE ER_ARRAY;       WriteF('Array index out of bounds\n')
  712.       CASE ER_FILE;        WriteF('File error\n')
  713.       CASE ER_GFXWIN;      WriteF('No User-window for graphics\n')
  714.       CASE ER_VALUES;      WriteF('Illegal value(s)\n')
  715.       CASE ER_KICK;        WriteF('You need OS 37+ for this function\n')
  716.     ENDSELECT
  717.     IF erpos<>NIL
  718.       StrCopy(erstr,erpos,ALL)
  719.       FOR a:=0 TO ERLEN-1 DO IF erstr[a]=10 THEN erstr[a]:=32
  720.       WriteF('NEARBY: \s\n',erstr)
  721.     ENDIF
  722.   ELSEIF nr=-1
  723.     WriteF('*** Program halted.\n')
  724.   ENDIF
  725.   IF conout<>NIL THEN WriteF('Press <return> to continue ...\n')
  726.   CleanUp(0)
  727. ENDPROC
  728.  
  729. keywords:
  730. CHAR 'write...', 'add.....', 'eq......', 'uneq....', 'sub.....',
  731.      'mul.....', 'div.....', 'and.....', 'or......', 'not.....',
  732.      'if......', 'do......', 'select..', 'set.....', 'for.....',
  733.      'while...', 'until...', 'defun...', 'lambda..', 'apply...',
  734.      'readint.', 'array...', 'greater.', 'smaller.', 'locate..',
  735.      'cls.....', 'dump....', 'window..', 'tell....', 'told....',
  736.      'see.....', 'seen....', 'string..', 'read....', 'get.....',
  737.      'put.....', 'filelen.', 'line....', 'plot....', 'box.....',
  738.      'mousex..', 'mousey..', 'mouse...', 'text....', 'abs.....',
  739.      'mod.....', 'eor.....', 'swap....', 'power...', 'req.....',
  740.      'inc.....', 'dec.....', 'rnd.....', 'rndq....', 'kick....',
  741.      'when....', 'else....', 'win.....', 'screen..', 'message.',
  742.      'gadget..', 'gadid...', 'hex.....', 'exit....'
  743.  
  744. /* doc file follows: (see end of doc for new v1.2 functions) */
  745.  
  746.  
  747. /*        +---------------------------------------+
  748.         |                                       |
  749.         |       Amiga YAX Interpreter v1.1      |
  750.         |                                       |
  751.         |            (c) 1992/93 $#%!           |
  752.         |              M A N U A L              |
  753.         |                                       |
  754.         +---------------------------------------+
  755.  
  756.             1. Introduction
  757.             2. The Language
  758.             3. Built-in Functions
  759.  
  760.         +---------------------------------------+
  761.         |    1. Introduction            |
  762.         +---------------------------------------+
  763.  
  764. update from v0.x/1.0 to 1.1:
  765. bug fixes:
  766. - negative number division failed!
  767. - box accepted illegal values
  768.  
  769. update from v1.1 to 1.2:
  770. - new functions, see below.
  771.  
  772. YAX stands for "Yet Another Instruction Code Set", as the author couldn't
  773. think of better name. YAX is a procedural language with LISP-syntax and
  774. evaluation, as well as somewhat lambda function application.
  775.  
  776. In this manual it is assumed the reader possesses knowledge of other
  777. languages, as all 'obvious' explanations are left out. Readers for whom
  778. YAX would be their first programming language are advised to read
  779. a standard text on the subject  8-).
  780.  
  781.         +---------------------------------------+
  782.         |    2. The Language            |
  783.         +---------------------------------------+
  784.  
  785. Structure.
  786. The basic building block of a YAX program is called a term.
  787. Examples of terms are:
  788.  
  789. integer constants:    1 2 100 -1
  790. string constants:    'a' 'hi folks!'
  791. variables:        a count
  792. function calls:        (+ 1 2) (* 3 (- 4 5))
  793.  
  794. a function call is a list '()' with as first item the name of the
  795. function to be applied, followed by its arguments. With few execeptions,
  796. arguments to functions are again terms, so expressions may be built
  797. to infinite complexity. The main task of the interpreter is to
  798. evaluate these terms recursively.
  799.  
  800. Format.
  801. between any two lexical elements, any number of spaces, tabs and linefeeds
  802. may be placed. Comments start with '/*' and end with '*/', may extend
  803. over several lines, and may be nested. following two statements are equal:
  804.  
  805. (if(eq a 1)(for b 1 10(write'blabla')))       /* ugly */
  806.  
  807. (if (eq a 1)
  808.   (for b 1 10 (write 'blabla'))               /* better */
  809. )
  810.  
  811.  
  812.         +---------------------------------------+
  813.         |    3. Built-in Functions        |
  814.         +---------------------------------------+
  815.  
  816. If not explicitly stated, functions return 0. type of arguments:
  817.  
  818. <term>        any term
  819. <iterm>        term that evaluates to integer
  820. <sterm>        term that evaluates to string
  821. <var>        term that is a variable
  822. <svar>        term that is a string variable
  823. <func>        term that evaluates to a function
  824. ...        any number of terms of the same type may follow
  825.  
  826.                            --> INTEGER MATH <--
  827.  
  828. (add <iterm> ...)     or    (+ <iterm> ...)
  829. (sub <iterm> ...)     or    (- <iterm> ...)
  830. (mul <iterm> ...)     or    (* <iterm> ...)
  831. (div <iterm> ...)     or    (/ <iterm> ...)
  832.  
  833. (and <iterm> ...)
  834. (or <iterm> ...)
  835. (not <iterm>)
  836.  
  837. (eq <iterm> ...)
  838. (uneq <iterm> <iterm>)
  839. (smaller <iterm> <iterm>)
  840. (greater <iterm> <iterm>)
  841.  
  842. These functions perform the functions you'd expect them to do.
  843. All boolean logic functions return true (-1) or false (0). and/or/not
  844. work as logical as well as bitwise operators.
  845. except for the last three, all functions handle any number of arguments,
  846. i.e.  (eq 10 (+ 1 2 3 4) (* 2 5))  is a valid term.
  847.  
  848.                          --> PROGRAM STRUCTURE <--
  849.  
  850. (for <var> <iterm> <iterm> <term> ...)
  851. (if <boolexp> <ifterm> <elseterm>)
  852.   /* also returns value of term */
  853. (do <term> ...)
  854. (select <iterm> <term> ...)
  855.   /* <iterm> is matched agains even items of <term>s, and 
  856.      corresponding odd <term> is executed */
  857. (while <term> <term> ...)
  858. (until <term> <term> ...)
  859. (set <var> <term>)
  860.  
  861. (defun <var> (<var> ...) <term> ...)
  862. (lambda (var ...) <term> ...)
  863.    /* returns function as value (may only be used in (set) and (apply) */
  864. (apply <func> <term> ...)
  865.  
  866. (array <var> <iterm>)
  867. (string <var>)
  868.  
  869.  
  870.                            --> INPUT OUTPUT <--
  871.  
  872. (write <term> ...)
  873. (locate <iterm> <iterm>)
  874. (cls)
  875. (window <iterm> <iterm> <iterm> <iterm> <sterm>)
  876.  
  877. (tell <sterm>)            open a file for writing
  878. (told)                close file
  879. (see <sterm>)            open a file for reading
  880. (seen)                close file
  881. (filelen <sterm>)        get filelength
  882.  
  883. (readint)            read an integer
  884. (read <svar>)            read a string
  885. (get)                read one character
  886. (put <iterm>)            write one character
  887.  
  888. (dump)                show all variables
  889.  
  890.  
  891.                              --> GRAPHICS <--
  892.  
  893. (line <iterm> <iterm> <iterm> <iterm> <iterm>)
  894. (plot <iterm> <iterm> <iterm>)
  895. (box <iterm> <iterm> <iterm> <iterm> <iterm>)
  896. (text <iterm> <iterm> <iterm> <iterm> <sterm>)
  897. (mousex), (mousey)        intuition
  898. (mouse)                non-intuition
  899.  
  900.  
  901.  
  902. NEW IN VERSION 1.2:
  903. - changes to existing functions:
  904.     (>) as equivalent for (greater)
  905.     (<) as equivalent for (smaller)
  906.     (array <var> <size> <iterm> ...)    /* inits array with <iterm>s (opt) */
  907.     (set <stringvar> <sterm>)
  908. - additional functions:
  909.   math etc.:
  910.     (abs <iterm>)
  911.     (mod <iterm> <iterm>)        /* (mod 20 3) => 2 */
  912.     (eor <iterm> ...)
  913.     (swap <var> <var>)            /* currently vars only */
  914.     (power <iterm> <iterm>)        /* (power 2 5) => 32 */
  915.     (inc <var>)
  916.     (dec <var>)
  917.   system:
  918.     (kick <iterm>)            /* (if (kick 37) ... ) */
  919.     (exit)
  920.   control:
  921.     (when <bterm> <term> ...        /* (if <bterm> (do <term> ...)  */
  922.              else <term> ...)        /*             (do <term> ...)) */
  923.   input/output:
  924.     (hex <iterm>)            /* writes num in hexadecimal */
  925.   intuition:
  926.     (req <sterm> <sterm> <sterm>)    /* (req 'YAX req' 'choose:' 'a|b|c') */
  927.     (screen w h d flags title)        /* opens screen */
  928.     (win x y w h IDCMP flags title)    /* opens gfx-only window and closes
  929.                        any previous w. if (screen) was
  930.                                            used, (win) opens on it */
  931.     (gadget id x y width title)         /* makes gadget on cur. window */
  932.     (message)                /* Wait()s and returns IDCMP */
  933.     (gadid)                /* returns gadnum in event */
  934.  
  935.   NOTE: now that there's (win) and (screen), graphics and intuition
  936.         functions should not be used on windows opened with (window)
  937.         (these are for stdio only), it will be possible however to use
  938.         graphics functions on them for backward compatability with 1.1.
  939.  
  940.  
  941. POSSIBLE ENHANCEMENTS:
  942. - true lambda's for function calls
  943.  
  944. ben:
  945. - string commands
  946. - run another yax prog from yax code
  947. - (see) twice --> problems? better file support.
  948. - yax compiler (to E)
  949.  
  950. */
  951.  
  952.